home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / macros.lisp < prev    next >
Text File  |  1990-12-06  |  5KB  |  158 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (IN-PACKAGE "CONDITIONS")
  4.  
  5. (EVAL-WHEN (EVAL COMPILE LOAD)
  6.  
  7. (DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P)
  8.   (DO ((L '())
  9.        (C CASES (CDR C)))
  10.       ((NULL C) (NREVERSE L))
  11.     (LET ((KEYS (CAAR C)))
  12.       (COND ((ATOM KEYS)
  13.          (COND ((NULL KEYS))
  14.            ((MEMBER KEYS '(OTHERWISE T))
  15.             (ERROR "OTHERWISE is not allowed in ~S expressions."
  16.                MACRO-NAME))
  17.            (T (PUSH KEYS L))))
  18.         (LIST-IS-ATOM-P
  19.          (PUSH KEYS L))
  20.         (T
  21.          (DOLIST (KEY KEYS) (PUSH KEY L)))))))
  22.  
  23. );NEHW-LAVE
  24.  
  25. (DEFMACRO ECASE (KEYFORM &REST CASES)
  26.   (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL))
  27.     (VAR (GENSYM)))
  28.     `(LET ((,VAR ,KEYFORM))
  29.        (CASE ,VAR
  30.      ,@CASES
  31.      (OTHERWISE
  32.        (ERROR 'CASE-FAILURE :NAME 'ECASE
  33.                   :DATUM ,VAR
  34.                 :EXPECTED-TYPE '(MEMBER ,@KEYS)
  35.                 :POSSIBILITIES ',KEYS))))))
  36.  
  37. (DEFMACRO CCASE (KEYPLACE &REST CASES)
  38.   (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL))
  39.     (TAG1 (GENSYM))
  40.     (TAG2 (GENSYM)))
  41.     `(BLOCK ,TAG1
  42.        (TAGBODY ,TAG2
  43.      (RETURN-FROM ,TAG1
  44.        (CASE ,KEYPLACE
  45.          ,@CASES
  46.          (OTHERWISE
  47.            (RESTART-CASE (ERROR 'CASE-FAILURE
  48.                     :NAME 'CCASE
  49.                     :DATUM ,KEYPLACE
  50.                     :EXPECTED-TYPE '(MEMBER ,@KEYS)
  51.                     :POSSIBILITIES ',KEYS)
  52.          (STORE-VALUE (VALUE)
  53.              :REPORT (LAMBDA (STREAM)
  54.                    (FORMAT STREAM "Supply a new value of ~S."
  55.                        ',KEYPLACE))
  56.              :INTERACTIVE READ-EVALUATED-FORM
  57.            (SETF ,KEYPLACE VALUE)
  58.            (GO ,TAG2))))))))))
  59.  
  60. (DEFMACRO ETYPECASE (KEYFORM &REST CASES)
  61.   (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T))
  62.     (VAR (GENSYM)))
  63.     `(LET ((,VAR ,KEYFORM))
  64.        (TYPECASE ,VAR
  65.      ,@CASES
  66.      (OTHERWISE
  67.        (ERROR 'CASE-FAILURE :NAME 'ETYPECASE
  68.                   :DATUM ,VAR
  69.                 :EXPECTED-TYPE '(OR ,@TYPES)
  70.                 :POSSIBILITIES ',TYPES))))))
  71.  
  72. (DEFMACRO CTYPECASE (KEYPLACE &REST CASES)
  73.   (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T))
  74.     (TAG1 (GENSYM))
  75.     (TAG2 (GENSYM)))
  76.     `(BLOCK ,TAG1
  77.        (TAGBODY ,TAG2
  78.      (RETURN-FROM ,TAG1
  79.        (TYPECASE ,KEYPLACE
  80.          ,@CASES
  81.          (OTHERWISE
  82.            (RESTART-CASE (ERROR 'CASE-FAILURE
  83.                     :NAME 'CTYPECASE
  84.                     :DATUM ,KEYPLACE
  85.                     :EXPECTED-TYPE '(OR ,@TYPES)
  86.                     :POSSIBILITIES ',TYPES)
  87.          (STORE-VALUE (VALUE)
  88.              :REPORT (LAMBDA (STREAM)
  89.                    (FORMAT STREAM "Supply a new value of ~S."
  90.                        ',KEYPLACE))
  91.              :INTERACTIVE READ-EVALUATED-FORM
  92.            (SETF ,KEYPLACE VALUE)
  93.            (GO ,TAG2))))))))))
  94.  
  95. (DEFUN ASSERT-REPORT (NAMES STREAM)
  96.   (FORMAT STREAM "Retry assertion")
  97.   (IF NAMES
  98.       (FORMAT STREAM " with new value~P for ~{~S~^, ~}."
  99.           (LENGTH NAMES) NAMES)
  100.       (FORMAT STREAM ".")))
  101.  
  102. (DEFUN ASSERT-PROMPT (NAME VALUE)
  103.   (COND ((Y-OR-N-P "The old value of ~S is ~S.~
  104.           ~%Do you want to supply a new value? "
  105.            NAME VALUE)
  106.      (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
  107.      (FLET ((READ-IT () (EVAL (READ *QUERY-IO*))))
  108.        (IF (SYMBOLP NAME) ;Help user debug lexical variables
  109.            (PROGV (LIST NAME) (LIST VALUE) (READ-IT))
  110.            (READ-IT))))
  111.     (T VALUE)))
  112.  
  113. (DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION)
  114.   (ERROR 'SIMPLE-TYPE-ERROR
  115.      :DATUM ASSERTION
  116.      :EXPECTED-TYPE NIL            ; This needs some work in next revision. -kmp
  117.      :FORMAT-STRING "The assertion ~S failed."
  118.      :FORMAT-ARGUMENTS (LIST ASSERTION)))
  119.  
  120. (DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS)
  121.   (LET ((TAG (GENSYM)))
  122.     `(TAGBODY ,TAG
  123.        (UNLESS ,TEST-FORM
  124.      (RESTART-CASE ,(IF DATUM
  125.                 `(ERROR ,DATUM ,@ARGUMENTS)
  126.                 `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM))
  127.        (CONTINUE ()
  128.            :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM))
  129.          ,@(MAPCAR #'(LAMBDA (PLACE)
  130.                `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE)))
  131.                PLACES)
  132.              (GO ,TAG)))))))
  133.  
  134. (DEFUN READ-EVALUATED-FORM ()
  135.   (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
  136.   (LIST (EVAL (READ *QUERY-IO*))))
  137.  
  138. (DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING)
  139.   (LET ((TAG1 (GENSYM))
  140.     (TAG2 (GENSYM)))
  141.     `(BLOCK ,TAG1
  142.        (TAGBODY ,TAG2
  143.      (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL))
  144.      (RESTART-CASE ,(IF TYPE-STRING
  145.                 `(ERROR "The value of ~S is ~S, ~
  146.                      which is not ~A."
  147.                     ',PLACE ,PLACE ,TYPE-STRING)
  148.                 `(ERROR "The value of ~S is ~S, ~
  149.                      which is not of type ~S."
  150.                     ',PLACE ,PLACE ',TYPE))
  151.        (STORE-VALUE (VALUE)
  152.            :REPORT (LAMBDA (STREAM)
  153.              (FORMAT STREAM "Supply a new value of ~S."
  154.                  ',PLACE))
  155.            :INTERACTIVE READ-EVALUATED-FORM
  156.          (SETF ,PLACE VALUE)
  157.          (GO ,TAG2)))))))
  158.